home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / tforth21.lha / tile-forth-2.1 / lib / mappings.f83 < prev    next >
Text File  |  1991-09-14  |  3KB  |  142 lines
  1. \
  2. \  MAPPINGS IN VECTOR REPRESENTATION
  3. \
  4. \  Copyright (C) 1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 6 August 1990
  15. \
  16. \  Last updated on: 7 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, blocks
  20. \
  21. \  Description:
  22. \       Management of mappings represented as a vector of cells. The
  23. \       mapping consists of pairs of values; domain and range and
  24. \       is terminated by the double value zero (nil). Thus double zero
  25. \       cannot be a member of mapping. Used mainly for extra values bound
  26. \       to entries when field space has not been allocated. 
  27. \
  28. \  Copying:
  29. \       This program is free software; you can redistribute it and\or modify
  30. \       it under the terms of the GNU General Public License as published by
  31. \       the Free Software Foundation; either version 1, or (at your option)
  32. \       any later version.
  33. \
  34. \       This program is distributed in the hope that it will be useful,
  35. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  36. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  37. \       GNU General Public License for more details.
  38. \
  39. \       You should have received a copy of the GNU General Public License
  40. \       along with this program; see the file COPYING.  If not, write to
  41. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  42.  
  43. .( Loading Mappings definitions...) cr
  44.  
  45. #include blocks.f83
  46.  
  47. vocabulary mappings ( -- )
  48.  
  49. blocks mappings definitions
  50.  
  51. 0       field +domain ( mapping -- addr) private
  52. cell    field +range ( mapping -- addr) private
  53. 2 cells field +pair ( mapping -- addr) private
  54.  
  55. : mapping ( size -- )
  56.   create 0 0 here 2! 2* cells allot
  57. ;
  58.  
  59. : empty-mapping ( mapping -- )
  60.   0 0 rot 2!
  61. ;
  62.  
  63. : ?empty-mapping ( mapping -- bool)
  64.   2@ or boolean not
  65. ;
  66.  
  67. : size-mapping ( mapping -- num)
  68.   0 swap
  69.   begin
  70.     dup 2@ or
  71.   while
  72.     swap 1+ swap +pair
  73.   repeat
  74.   drop
  75. ;
  76.  
  77. : search-mapping ( domain mapping -- [addr1] or [domain addr2 false])
  78.   swap >r
  79.   begin
  80.     dup 2@ or
  81.   while
  82.     dup +domain @ r@ =
  83.     if r> drop exit then
  84.     +pair
  85.   repeat
  86.   r> swap false
  87. ; private
  88.  
  89. : add-mapping ( range domain mapping -- )
  90.   search-mapping ?dup if +range ! else dup 0 0 rot +pair 2! 2! then
  91. ;
  92.  
  93. : remove-mapping ( domain mapping -- )
  94.   search-mapping ?dup
  95.   if
  96.     begin
  97.       dup +pair tuck
  98.       2@ 2dup or boolean not >r rot 2! r>
  99.     until
  100.     drop
  101.   else
  102.     2drop
  103.   then
  104. ;
  105.  
  106. : ?range-mapping ( domain mapping -- bool)
  107.   search-mapping if true else 2drop false then
  108. ;
  109.  
  110. : range-mapping ( domain mapping -- addr)
  111.   search-mapping ?dup if +range else 2drop nil then
  112. ;
  113.  
  114. : map-mapping ( mapping block[range domain -- ] -- )
  115.   >r
  116.   begin
  117.     dup 2@ 2dup or
  118.   while
  119.     rot r@ swap >r call r> +pair
  120.   repeat
  121.   r> 2drop 2drop
  122. ;
  123.  
  124. : ?map-mapping ( mapping block[range domain -- bool] -- )
  125.   >r
  126.   begin
  127.     dup 2@ 2dup or
  128.   while
  129.     rot r@ swap >r call r> swap if r> 2drop exit then +pair
  130.   repeat
  131.   r> 2drop 2drop
  132. ;
  133.  
  134. : .mapping ( mapping -- )
  135.   ." { "
  136.   block[ ( range domain -- ) ." ( " .name space . ." ) " ];
  137.   map-mapping
  138.   ." } "
  139. ;
  140.  
  141. forth only
  142.